home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 050 / xref.arc / XREF.PAS < prev   
Pascal/Delphi Source File  |  1985-06-19  |  28KB  |  934 lines
  1. {$C-}  {* essential for programmed pause-abort facility;
  2.                                   see procedure dealwithuser *}
  3. program xrefpas;
  4. (*
  5.  Cross reference generator Version 1.10, 5/8/85
  6.  
  7.           ------> REQUIRES TURBO PASCAL 3.0 <------
  8.                                         --- (explained below)
  9.  
  10.      ******************* NEW PARAGRAPH!!!!!! *********************
  11.   Whoops! Looks like there was a bug in the original version which resulted
  12.   in page-breaks occurring in the wrong places, especially when include files
  13.   were involved.  This has been corrected, but who knows what else is wrong.
  14.   I hope soon to have an MCI mail box through which I can communicate with
  15.   you, my fans out there.  In the meantime, prepare those suggestions for
  16.   improvements in XREF, or TURBO utilities in general, cause I really get
  17.   off on writing these things.
  18.      *************************************************************
  19.  
  20.   This program, in its original form, was downloaded off of some bulletin
  21.   board somewhere.  At that point, it only listed a Pascal program to the
  22.   LST device and generated a cross reference of whatever reserved words
  23.   were in the list in function rsvdword, with those reserved boldfaced in
  24.   the printout.  I have made numerous improvements.
  25.  
  26.   The program now optionally lists include files within the source listing.
  27.   At any point during listing, printing may be interrupted by pressing any
  28.   key, at which point you can either resume the listing or abort.
  29.   The listing can be sent to the printer, the screen, or a disk file.
  30.   If sent to the screen, reserved appear in reverse video.  If output is
  31.   to the printer or a file, the screen displays the name of the file being
  32.   listed, with include files indented, and the line number of output.
  33.   File names supplied by the user, i.e. the file to be listed and optional
  34.   output file, are checked by function file_exists, which is cool in that
  35.   it does not need to open the file.  In fact, there are several subroutines
  36.   within this program which would be useful for general purpose TURBO Pascal
  37.   programming.
  38.  
  39.   You should note that many of the new functions of XREF use TURBO features
  40.   which are specific to the IBM-PC version, such as the reverse video and
  41.   use of wherex and wherey.
  42.  
  43.   I can't think of anything else one would need in a source listing program.
  44.   If someone else can, or has any questions about the program, please contact
  45.   me at this address:
  46.  
  47.             Larry Jay Seltzer
  48.             657 Seventh Street
  49.             Lakewood, NJ  08701
  50.  
  51.   The compressed and default mode options work for the Epson FX-100 and
  52.   any compatable printer.  The codes are stored in CONSTants, so as to
  53.   be easily changeable for any printer with this capacity.  There are three
  54.   basic ways to invoke the program:
  55.  
  56.              1) XREF from command line.  You will be prompted for everything.
  57.              2) XREF [pathname][filename].[ext]
  58.                        You will be prompted for all applicable parameters.
  59.              3) XREF [pathname][filename].[ext] [/ { C, D, F, I, N, S } ]
  60.                         C means print out in compressed mode (EPSON)
  61.                         D means print out in default mode
  62.                         F means print out to disk file
  63.                         I means list include files within the main
  64.                         N means exclude the cross refernce
  65.                         S means send output to the screen instead of printer.
  66.  
  67.   Note that the recursive nature of the actual listing procedure (do_listing)
  68.   allows for any nesting level of INCLUDEs, even though TURBO Pascal does not
  69.   allow INCLUDEs to be nested.  So this is nice, but of questionable value.
  70.  
  71.   The program requires TURBO 3.0 because it uses TURBO FIBs, which have been
  72.   altered for version 3.0.  The FIB no longer contains the file's date of
  73.   creation, so the file handle is passed to DOS function call $57, which
  74.   returns the date.
  75.  
  76.  >>>> This should be compiled into a COM file
  77.                        by Turbo Pascal(tm) 3.0 or later before running.
  78.                                               What Borland hath wrought!!! <<<<
  79. *)
  80.  
  81. const
  82.   ch_per_word = 22; { characters per word }
  83.   linenums = 11; { line numbers per printed reference line }
  84.   linenum_size =  5; { size of displayed line numbers }
  85.   reserved_count = 208; { number of reserved words }
  86.  
  87. {*** printer control sequences ***}
  88.   compressed_on : array[1..1] of char = (#15);
  89.   default_on : array[1..2] of char = (#27,#64);
  90.   boldface_on : array[1..2] of char = (#27,#69);
  91.   boldface_off : array[1..2] of char = (#27,#70);
  92.  
  93. type
  94.   datestr = string[10];
  95.   option_type = string[1];
  96.   switchsettype = set of char;
  97.   wordref = ^word;
  98.   itemref = ^item;
  99.   word = record key: string[ch_per_word];
  100.                 first, last: itemref;
  101.                 left, right: wordref;
  102.          end ;
  103.   item = record lno: integer;
  104.                 next: itemref;
  105.          end ;
  106.   state = (none,symbol,quote,com1,pcom2,com2,pcom2x);
  107.   filstring = string[64];
  108.   titletype = string[10];
  109. var
  110.   filename, incname, outname : filstring;
  111.   root:  wordref;
  112.   m,n,
  113.   linenum  : integer;
  114.   id:    string[127];
  115.   fv,iv,
  116.   outf   :    text;
  117.   f,lastf :    char;
  118.   switch : char;
  119.   switches : switchsettype;
  120.   scan, tscan:  state;
  121.   pageno:integer;
  122.   title: titletype;
  123.   taken_careof,
  124.   parsing_for_dollars,
  125.   itsa_directive,
  126.   itsan_include         : boolean;
  127.   cutoff : integer;
  128.  
  129. function file_exists(var thefile : filstring) : boolean;
  130. type
  131.        Registertype = record
  132.                AX,BX,CX,DX,
  133.                BP,SI,DI,DS,ES,flags: integer;
  134.        end;
  135.  
  136. VAR
  137.        registers:registertype;
  138.  
  139. begin
  140.  thefile := thefile + #0;
  141.  with registers do
  142.   begin
  143.    ds := seg(thefile);
  144.    dx := ofs(thefile)+1;
  145.    ax := $4E00;
  146.    cx := $0000
  147.   end;
  148.  intr($21,registers);
  149.  file_exists := not ((registers.flags and $0001) = $0001)
  150. end;
  151.  
  152.  
  153. function currdate: DateStr;
  154. type
  155.   regpack = record
  156.               ax,bx,cx,dx,bp,si,ds,es,flags: integer;
  157.             end;
  158.  
  159. var
  160.   recpack:       regpack;                {record for MsDos call}
  161.   month,day:     string[2];
  162.   year:          string[4];
  163.   tempdate:      datestr;
  164.   i,dx,cx:       integer;
  165.  
  166. begin
  167.   with recpack do
  168.   begin
  169.     ax := $2a shl 8;
  170.   end;
  171.   MsDos(recpack);                        { call function }
  172.   with recpack do
  173.   begin
  174.     str(cx,year);                        {convert to string}
  175.     str(dx mod 256,day);                     { " }
  176.     str(dx shr 8,month);                     { " }
  177.   end;
  178.   tempdate := month+'/'+day+'/'+year;
  179.   for i:= 1 to 10 do if tempdate[i] = ' ' then tempdate[i]:= '0';
  180.   currdate := tempdate
  181. end;
  182.  
  183. function filedate(var thefile : text) : datestr;
  184.   type
  185.    regpack = record
  186.               al, ah : byte;
  187.               bx,cx,dx,bp,si,ds,es,flags: integer;
  188.              end;
  189.   var
  190.    sortofdate,
  191.    i, handle : integer;
  192.    month,day : string[2];
  193.    year : string[4];
  194.    date : datestr;
  195.    recpack : regpack;
  196.  
  197. begin
  198.     handle := memw [seg(thefile):ofs(thefile)];
  199.     recpack.al := 0;
  200.     recpack.AH := $57;
  201.     recpack.bx := handle;
  202.     msdos(recpack);
  203.     sortofdate := recpack.dx;
  204.     str(((sortofdate shr 9) + 1980):4,year);
  205.     str(((sortofdate shr 5) and $000F):2,month);
  206.     str((sortofdate and $001F):2,day);
  207.     date:= month + '/' + day + '/' + year;
  208.     for i:= 1 to 10 do if date[i] = ' ' then date[i]:= '0';
  209.     filedate := date
  210. end;  {WhenCreated}
  211.  
  212. procedure newpage(var fname : filstring;title:titletype);
  213.  var date : datestr;
  214.      date_stuff : string[40];
  215.   begin
  216.     pageno := pageno+1;
  217.     date_stuff := 'Created '+filedate(fv)+'  '+'Listed '+currdate;
  218.     If (not ('S' in switches)) and (not ('F' in switches))
  219.      then write(outf,#12) else writeln(outf);
  220.     write(outf,title,': ',fname,' ':6,date_stuff,' ':6,'Page ',pageno:3);
  221.     writeln(outf);
  222.     writeln(outf);
  223.   end {newpage};
  224.  
  225. procedure writeid;
  226. var xx : integer;
  227.   function rsvdword: boolean;
  228.     const
  229.       wordlist: array[1..reserved_count] of string[14] =
  230.         ('ABSOLUTE','ADDR','AND','ARC','ARCTAN','ARRAY','ASSIGN','AUX',
  231.          'AUXINPTR','AUXOUTPTR','BACK',
  232.          'BEGIN','BLOCKREAD','BLOCKWRITE','BOOLEAN','BYTE',
  233.          'CASE','CHAIN','CHAR','CHDIR','CHR','CIRCLE','CLEARSCREEN',
  234.          'CLOSE','CLREOL','CLRSCR','COLORTABLE','CON','CONCAT','CONINPTR',
  235.          'CONOUTPTR','CONST',
  236.          'CONSTPTR','COPY','COS','CRTEXIT','CRTINIT','CSEG','DELAY',
  237.          'DELETE','DELLINE','DISPOSE',
  238.          'DIV','DO','DOWNTO','DRAW','ELSE','END','END.','EOF','EOLN','ERASE',
  239.          'EXECUTE','EXP','EXTERNAL','FALSE','FILE','FILEPOS','FILESIZE',
  240.          'FILLCHAR','FILLPATTERN','FILLSCREEN','FILLSHAPE',
  241.          'FLUSH','FOR','FORWARD','FRAC','FREEMEM',
  242.          'FUNCTION','GETDIR','GETDOT',
  243.          'GETMEM','GETPIC','GOTO','GOTOXY',
  244.          'GRAPHBACKGROUND','GRAPHCOLORMODE',
  245.          'GRAPHMODE','GRAPHWINDOW','HALT','HEAPPTR',
  246.          'HEADING','HI','HIDETURTLE',
  247.          'HIRES','HIRESCOLOR','HOME',
  248.          'IF','IN','INLINE','INPUT','INSERT','INSLINE','INT','INTEGER','INTR',
  249.          'IORESULT','KBD','KEYPRESSED','LABEL','LENGTH','LN','LO','LOWVIDEO',
  250.          'LST','LSTOUTPTR','MARK','MAXAVAIL',
  251.          'MAXINT','MEMAVAIL','MEMW','MKDIR','MOD',
  252.          'MOVE','MSDOS','NEW','NIL','NORMVIDEO','NOSOUND',
  253.          'NOT','ODD','OF','OFS','OR','ORD','OUTPUT','OVERLAY',
  254.          'PACKED','PALETTE','PARAMCOUNT','PARAMSTR','PATTERN',
  255.          'PENDOWN','PENUP',
  256.          'PI','PLOT','PORT','POS','PRED','PROCEDURE',
  257.          'PROGRAM','PTR','PUTPIC','RANDOM','RANDOMIZE','READ','READLN','REAL',
  258.          'RECORD','RELEASE','RENAME','REPEAT','RESET',
  259.          'REWRITE','RMDIR','ROUND','SEEK','SEEKEOF','SEEKEOLN',
  260.          'SEG','SET','SETHEADING','SETPENCOLOR','SETPOSITION',
  261.          'SHL','SHOWTURTLE','SHR','SIN','SIZEOF','SOUND',
  262.          'SQR','SQRT','STR','STRING',
  263.          'SUCC','SWAP','TEXT','TEXTBACKGROUND','TEXTCOLOR','TEXTMODE',
  264.          'THEN','TO','TRM','TRUE','TRUNC',
  265.          'TURNLEFT','TURNRIGHT','TURTLETHERE','TURTLEWINDOW','TYPE',
  266.          'UNTIL','UPCASE','USR','USRINPTR','USROUTPTR','VAL','VAR',
  267.          'WHEREX','WHEREY','WHILE','WINDOW',
  268.          'WITH','WRAP','WRITE','WRITELN','XCOR','XOR','YCOR');
  269.     var
  270.       i, j, k: integer;
  271.       upid:    string[127];
  272.     begin
  273.       upid := '';
  274.       for i := 1 to length(id) do
  275.         upid := upid + upcase(copy(id,i,1));
  276.       i := 1;
  277.       j := reserved_count - 1;
  278.       repeat
  279.         k := (i+j) div 2;
  280.         if upid > wordlist[k] then i := k+1
  281.                             else j := k
  282.     until i = j;
  283.     rsvdword := (upid = wordlist[i])
  284.     end {rsvdword};
  285.  
  286.   procedure search (var w1: wordref);
  287.     var w: wordref;
  288.         x: itemref;
  289.     begin
  290.       w := w1;
  291.       if w = nil then
  292.       begin
  293.         new(w);
  294.         new(x);
  295.         with w^ do
  296.         begin
  297.           key := id;
  298.           left := nil;
  299.           right := nil;
  300.           first := x;
  301.           last := x
  302.         end ;
  303.         x^.lno := n;
  304.         x^.next := nil;
  305.         w1 := w
  306.       end
  307.       else
  308.       if id < w^.key then search(w^.left)
  309.       else
  310.       if id > w^.key then search(w^.right)
  311.       else
  312.       begin
  313.         new(x);
  314.         x^.lno := n;
  315.         x^.next := nil;
  316.         w^.last^.next := x;
  317.         w^.last := x
  318.       end
  319.     end {search} ;
  320.  
  321.  
  322.     Procedure Regular_video;
  323.     begin
  324.         TextBackground(black);
  325.         TextColor(white);
  326.     end;
  327.  
  328.     Procedure Reverse_video;
  329.     begin
  330.         TextBackground(white);
  331.         TextColor(black);
  332.     end;
  333.  
  334.   FUNCTION locase(ch:char) : char;
  335.   BEGIN
  336.    If ch in ['A'..'Z']
  337.     then locase := chr(ord(ch) or $20)
  338.     else locase := ch
  339.   END;
  340.  
  341.   begin
  342.     if rsvdword then
  343.      if 'F' in switches
  344.       then
  345.        write(outf,id)
  346.       else
  347.        if 'S' in switches
  348.         then
  349.          begin
  350.           reverse_video;
  351.           write(outf,id);
  352.           regular_video
  353.          end
  354.         else
  355.          write(outf,boldface_on,id,boldface_off)
  356.     else
  357.     begin
  358.       write(outf,id);
  359.       If not ('N' in switches)
  360.        then
  361.         begin
  362.          for xx := 1 to length(id) do
  363.           id[xx] := locase(id[xx]);
  364.          search(root)
  365.         end
  366.     end
  367.   end {writeid};
  368.  
  369.   procedure scrn_update(indent : boolean);
  370.   const
  371.    mainx = 18;
  372.    incx = 20;
  373.  
  374.   begin
  375.    if indent
  376.     then
  377.      gotoxy(incx,wherey)
  378.     else
  379.      gotoxy(mainx,wherey);
  380.    write(n:1)
  381.   end;
  382.  
  383. procedure printtree (w:wordref);
  384.  
  385.   procedure printword (w:word);
  386.     var l: integer;
  387.         x: itemref;
  388.     begin
  389.       if (n mod 60) = 0 then
  390.         newpage(filename,'xref');
  391.       write(outf,' ',w.key:ch_per_word);
  392.       x := w.first;
  393.       l:= 0;
  394.       repeat
  395.         if l = linenums then
  396.         begin
  397.           writeln(outf);
  398.           n := n+1;
  399.           scrn_update(false);
  400.           if (n mod 60) = 0 then
  401.             newpage(filename,'xref');
  402.           write(outf,' ':ch_per_word+1);
  403.           l := 0
  404.         end ;
  405.         l := l+1;
  406.         write(outf,x^.lno:linenum_size);
  407.         x := x^.next
  408.       until x = nil;
  409.      writeln(outf);
  410.      n := n+1;
  411.      scrn_update(false)
  412.     end {printword} ;
  413.   begin
  414.    if w <> nil then
  415.     begin
  416.       printtree(w^.left);
  417.       printword(w^);
  418.       printtree(w^.right)
  419.     end
  420.   end {printtree} ;
  421.  
  422.  
  423.  function get_answer(opt1,opt2 : option_type) : option_type;
  424.   var ch : char;
  425.    begin
  426.     repeat
  427.      read(kbd,ch)
  428.     until ch in [opt1,opt2,upcase(opt1),upcase(opt2)];
  429.     writeln(ch);
  430.     get_answer := upcase(ch)
  431.    end;
  432.  
  433.  function get_choices(opt1,opt2,opt3 : option_type) : option_type;
  434.   var ch : char;
  435.    begin
  436.     repeat
  437.      read(kbd,ch)
  438.     until ch in [opt1,opt2,opt3,upcase(opt1),upcase(opt2),upcase(opt3)];
  439.     writeln(ch);
  440.     get_choices := upcase(ch)
  441.    end;
  442.  
  443.  procedure empty_keyboard;
  444.   var
  445.    c : char;
  446.   begin
  447.    while keypressed do
  448.     read(kbd,c)
  449.   end;
  450.  
  451.  Procedure do_listing(var fv : text;title:titletype ;
  452.                                      fn : filstring ; mode : state);
  453.  
  454.   procedure bugout;
  455.    begin
  456.     parsing_for_dollars := false;
  457.     itsan_include := false;
  458.     itsa_directive := false
  459.    end;
  460.  
  461.   procedure dealwithuser;
  462.    var
  463.     oldx,oldy : integer;
  464.     answer : option_type;
  465.     c : char;
  466.    begin
  467.     empty_keyboard;
  468.     oldx:=wherex; oldy:=wherey;
  469.     writeln;
  470.     write('Press space to continue, Esc to abort ...');
  471.     answer := get_answer(#32,#27);
  472.     if answer=#27 then halt
  473.      else
  474.       begin
  475.        gotoxy(wherex,wherey-1);
  476.        delline;
  477.        if (oldy=25) or (oldy=23)
  478.         then oldy := 23;
  479.        gotoxy(oldx,oldy)
  480.       end
  481.    end;
  482.  
  483.   procedure isitan_include;
  484.   begin
  485.    while f=' ' do
  486.     begin
  487.      write(outf,f);
  488.      read(fv,f)
  489.     end;
  490.    incname:='';
  491.    repeat
  492.     incname :=incname + f;
  493.     read(fv,f);
  494.     write(outf,f)
  495.    until not (f in ['.','A'..'Z','a'..'z','_','0'..'9']);
  496.    if pos('.',incname)=0 then incname := incname + '.PAS';
  497.    cutoff := n;
  498.    assign(iv,incname);
  499.    if not ('S' in switches)
  500.     then
  501.      begin
  502.       writeln;writeln;
  503.       write('  Listing include file ',incname);
  504.       if 'F' in switches
  505.        then writeln(' to file ',outname)
  506.        else writeln;
  507.       write('  Processing line #')
  508.      end;
  509.    newpage(incname,'Include');
  510.    taken_careof := true;
  511.    do_listing(iv,'Include',incname,none);
  512.    newpage(fn,title);
  513.    cutoff := n;
  514.    taken_careof := true;
  515.    close(iv);
  516.    if not ('S' in switches)
  517.     then
  518.      begin
  519.       writeln;writeln;
  520.       write('Listing main file ',filename);
  521.       if 'F' in switches
  522.        then writeln(' to file ',outname)
  523.        else writeln;
  524.       write('Processing line #')
  525.      end;
  526.    parsing_for_dollars := false;
  527.    itsa_directive := false;
  528.    itsan_include := false;
  529.   end;
  530.  
  531.  begin
  532.   cutoff := n;
  533.   scan := mode;
  534.   parsing_for_dollars := false;
  535.   itsa_directive := false;
  536.   itsan_include := false;
  537.   reset(fv);
  538.   if title='Main'
  539.    then newpage(fn,title);
  540.   while not eof(fv) do
  541.   begin
  542.     if (n-(60+cutoff)) = 0
  543.      then
  544.       begin
  545.        cutoff := cutoff+60;
  546.        if not taken_careof then
  547.         newpage(fn,title)
  548.       end;
  549.     taken_careof := false;
  550.     n := n+1;
  551.     if not ('S' in switches)
  552.      then
  553.       scrn_update(title='Include');
  554.     write(outf,n:linenum_size,' ');
  555.     while not eoln(fv) do
  556.     begin
  557.       if keypressed
  558.        then dealwithuser;
  559.       read(fv,f);
  560.       case scan of
  561.         none:   begin
  562.                   if f in['a'..'z','A'..'Z','_'] then
  563.                   begin
  564.                     id := f;
  565.                     scan := symbol
  566.                   end
  567.                   else
  568.                   begin
  569.                    write(outf,f);
  570.                    if f = '''' then scan := quote
  571.                     else
  572.                     if f = '{' then
  573.                      begin
  574.                       scan := com1;
  575.                       If 'I' in switches then parsing_for_dollars := true
  576.                      end
  577.                     else
  578.                     if f = '(' then scan := pcom2
  579.                   end
  580.                 end;
  581.         symbol: begin
  582.                   if f in['.','a'..'z','A'..'Z','0'..'9','_'] then
  583.                   begin
  584.                     id := id + f;
  585.                   end
  586.                   else
  587.                   begin
  588.                     writeid;
  589.                     write(outf,f);
  590.                     if f = '''' then scan := quote
  591.                     else
  592.                     if f = '{' then
  593.                      begin
  594.                       scan := com1;
  595.                       if 'I' in switches then parsing_for_dollars := true
  596.                      end
  597.                     else
  598.                     if f = '(' then scan := pcom2
  599.                     else
  600.                     scan := none
  601.                   end
  602.                 end;
  603.         quote:  begin
  604.                   write(outf,f);
  605.                   if f = '''' then scan := none
  606.                 end;
  607.         com1:   begin
  608.                   write(outf,f);
  609.                   if (f='+') or (f='-')
  610.                    then bugout;
  611.                   If itsan_include
  612.                    then
  613.                     begin
  614.                      isitan_include;
  615.                      f:='}'
  616.                     end;
  617.                   If itsa_directive
  618.                    then
  619.                     if (f = 'I') or (f='i')
  620.                      then
  621.                       begin
  622.                        itsan_include := true;
  623.                        itsa_directive := false
  624.                       end
  625.                      else
  626.                       itsa_directive := false;
  627.                   If parsing_for_dollars
  628.                    then
  629.                     if f = '$'
  630.                      then
  631.                       begin
  632.                        parsing_for_dollars :=false;
  633.                        itsa_directive := true
  634.                       end
  635.                      else
  636.                       parsing_for_dollars := false;
  637.                   if f = '}' then
  638.                    begin
  639.                     parsing_for_dollars := false;
  640.                     itsa_directive := false;
  641.                     itsan_include := false;
  642.                     scan := none
  643.                    end
  644.                 end;
  645.         pcom2:  begin
  646.                   if f in['a'..'z','A'..'Z','_'] then
  647.                   begin
  648.                     id := f;
  649.                     scan := symbol
  650.                   end
  651.                   else
  652.                   begin
  653.                     write(outf,f);
  654.                     if f = '''' then scan := quote
  655.                     else
  656.                     if f = '{' then
  657.                      begin
  658.                       scan := com1;
  659.                       if 'I' in switches then parsing_for_dollars := true
  660.                      end
  661.                     else
  662.                     if f = '(' then scan := pcom2
  663.                     else
  664.                     if f = '*' then
  665.                      begin
  666.                       scan := com2;
  667.                       if 'I' in switches then parsing_for_dollars := true
  668.                      end
  669.                     else
  670.                     scan := none
  671.                   end
  672.                 end;
  673.         com2:   begin
  674.                   write(outf,f);
  675.                   if (f='+') or (f='-')
  676.                    then bugout;
  677.                   If itsan_include
  678.                    then
  679.                     begin
  680.                      isitan_include;
  681.                      f:='}'
  682.                     end;
  683.                   If itsa_directive
  684.                    then
  685.                     if (f = 'I') or (f='i')
  686.                      then
  687.                       begin
  688.                        itsan_include := true;
  689.                        itsa_directive := false
  690.                       end
  691.                      else
  692.                       itsa_directive := false;
  693.                   If parsing_for_dollars
  694.                    then
  695.                     if f = '$'
  696.                      then
  697.                       begin
  698.                        itsa_directive := true;
  699.                        parsing_for_dollars := false
  700.                       end
  701.                      else
  702.                       parsing_for_dollars := false;
  703.                   if f = '*' then
  704.                     scan := pcom2x
  705.                    else
  706.                     if (f = ')') and (lastf='*')
  707.                      then
  708.                       begin
  709.                        parsing_for_dollars := false;
  710.                        itsa_directive := false;
  711.                        itsan_include := false;
  712.                        scan := none
  713.                       end
  714.                 end;
  715.         pcom2x: begin
  716.                   write(outf,f);
  717.                   if (f = ')')
  718.                    then scan := none
  719.                    else
  720.                       begin
  721.                        scan := com2;
  722.                        lastf:=f
  723.                       end
  724.                 end;
  725.       end;
  726.     end;
  727.     if scan = symbol then
  728.     begin
  729.       writeid;
  730.       scan := none
  731.     end;
  732.     writeln(outf);
  733.     readln(fv);
  734.   end
  735.  end;
  736.  
  737. procedure get_info;
  738.  var
  739.   i : integer;
  740.   parameters : string[127] absolute cseg:$0080;
  741.   workparams : string[127];
  742.  
  743.  procedure get_filename;
  744.  begin
  745.   M := 0;
  746.   repeat
  747.     M := M+1
  748.   until (M > length(workparams)) or (workparams[M] <> ' ');
  749.   N:=M;
  750.   REPEAT
  751.     N:=N+1
  752.   UNTIL (N>length(workparams)) OR (workparams[N]='/');
  753.   filename := copy(workparams,m,(n-m))
  754.  end;
  755.  
  756.  procedure waytogo_user;  {* filename and switches on command line *}
  757.  begin
  758.   n := pos('/',workparams) + 1;
  759.   While n<=length(workparams) do
  760.    begin
  761.     if upcase(workparams[n]) in ['C','D','F','I','N','S']
  762.      then switches := switches + [upcase(workparams[n])];
  763.     n:=n+1
  764.    end
  765.  end;
  766.  
  767.  procedure query_filename;
  768.  begin
  769.   write('Enter name of file to be listed [.PAS] : ');
  770.   readln(filename);
  771.   if pos('.',filename)=0
  772.    then filename := filename + '.PAS'
  773.  end;
  774.  
  775.  procedure switch_menu;
  776.  var answer : char;
  777.  begin
  778.   write('Output to file, screen, or printer (F,S,P) ? ');
  779.   answer := get_choices('f','s','p');
  780.   If answer = 'P'
  781.    then
  782.     begin
  783.      write('Printer output in compressed or default mode (C,D) ? ');
  784.      if get_answer('c','d') = 'C'
  785.       then switches := switches + ['C']
  786.       else switches := switches + ['D']
  787.     end
  788.    else
  789.     if answer='S'
  790.      then switches := switches + ['S']
  791.      else
  792.       begin
  793.        switches := switches + ['F'];
  794.        write('Enter name of output file [',copy(filename,1,
  795.                                       pos('.',filename)-1),'.','LST]');
  796.        readln(outname);
  797.        if outname=''
  798.         then outname := copy(filename,1,pos('.',filename)-1)+'.'+'LST'
  799.       end;
  800.   write('List Include files within the Main listing (Y,N) ? ');
  801.   if get_answer('y','n') = 'Y'
  802.    then switches := switches + ['I'];
  803.   write('Produce cross reference of user-defined identifiers (Y,N) ? ');
  804.   if get_answer('y','n') = 'N'
  805.    then switches := switches + ['N'];
  806.  end;
  807.  
  808. begin
  809.  workparams := parameters;
  810. { while workparams[LENGTH(workparams)]=#0 DO
  811.    delete(workparams,length(workparams),1);}
  812.  If pos('/',workparams)>0 then
  813.   If pos('/',workparams)<=length(workparams) then
  814.    begin
  815.     get_filename;
  816.     if not file_exists(filename)
  817.      then
  818.       begin
  819.        writeln('File ',filename,' not found.');
  820.        repeat
  821.         query_filename;
  822.         if not file_exists(filename)
  823.          then writeln('File ',filename,' not found.');
  824.        until file_exists(filename);
  825.        switch_menu
  826.       end
  827.      else
  828.       waytogo_user
  829.    end
  830.   else
  831.    begin
  832.     get_filename;
  833.     if not file_exists(filename)
  834.      then
  835.       begin
  836.        writeln('File ',filename,' not found.');
  837.        repeat
  838.         query_filename
  839.        until file_exists(filename);
  840.       end;
  841.     switch_menu
  842.    end
  843.  else
  844.   begin
  845.    if length(workparams)=0
  846.     then query_filename
  847.     else get_filename;
  848.     if not file_exists(filename)
  849.      then
  850.       begin
  851.        writeln('File ',filename,' not found.');
  852.        repeat
  853.         query_filename;
  854.         if not file_exists(filename)
  855.          then writeln('File ',filename,' not found.')
  856.        until file_exists(filename);
  857.       end;
  858.    switch_menu
  859.   end;
  860.  while filename[LENGTH(filename)]=#0 DO
  861.   delete(filename,length(filename),1)
  862. end;
  863.  
  864. begin  {*** main ***}
  865.   switches := [];
  866.   lastf:=' ';  {*** to prevent an error; see CASE scan of com2,pcom2x ***}
  867.   get_info;
  868.   empty_keyboard;
  869.   if (not ('F' in switches)) and (not ('S' in switches))
  870.    then
  871.     begin
  872.      If 'C' in switches
  873.       then writeln(lst,compressed_on);
  874.      If 'D' in switches
  875.       then writeln(lst,default_on)
  876.     end;
  877.   if 'S' in switches
  878.    then
  879.     begin
  880.      assign(outf,'CON:');
  881.      rewrite(outf)
  882.     end
  883.    else
  884.     if 'F' in switches
  885.      then
  886.       begin
  887.        assign(outf,outname);
  888.        rewrite(outf)
  889.       end
  890.      else
  891.       begin
  892.        assign(outf,'LST:');
  893.        rewrite(outf)
  894.       end;
  895.   root := nil;
  896.   n := 0;
  897.   cutoff := 0;
  898.   scan := none;
  899.   pageno := 0;
  900.   title := 'Main';
  901.   if not ('S' in switches)
  902.    then
  903.     begin
  904.      writeln;
  905.      write('Listing main file ',filename);
  906.      if 'F' in switches
  907.       then writeln(' to file ',outname)
  908.       else writeln;
  909.      write('Processing line #')
  910.     end;
  911.   assign(fv,filename);
  912.   do_listing(fv,title,filename,none);
  913.   if not ('N' in switches)
  914.    THEN
  915.     BEGIN
  916.      if not ('S' in switches)
  917.       then
  918.        begin
  919.         writeln;
  920.         write('Listing cross reference of ',filename);
  921.         if 'F' in switches
  922.          then writeln(' to file ',outname)
  923.          else writeln;
  924.         write('Processing line #')
  925.        end;
  926.      n := 0;
  927.      pageno := 0;
  928.      title := 'xref';
  929.      printtree(root);
  930.      If (not ('S' in switches)) and (not ('F' in switches))
  931.       then write(outf,#12)
  932.     END
  933. end.
  934.